home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _c3ff7e99ec0c01b56a009e03c63c7f20 < prev    next >
Encoding:
Text File  |  2002-05-30  |  3.1 KB  |  101 lines
  1. # filebox.tcl --
  2. #
  3. # This demonstration script prompts the user to select a file.
  4. #
  5. # SCCS: @(#) filebox.tcl 1.3 97/03/02 16:22:36
  6.  
  7. use vars qw/$TOP/;
  8.  
  9. sub filebox {
  10.     my $demo = shift;
  11.  
  12.     $TOP = $MW->WidgetDemo
  13.       (
  14.        -name     => $demo,
  15.        -text     => "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog.",
  16.        -title    => 'File box Demonstration',
  17.        -iconname => 'filebox',
  18.       );
  19.     foreach my $i (qw(open save)) {
  20.     my $f = $TOP->Frame;
  21.     my $lab = $f->Label(-text => "Select a file to $i: ",
  22.                 -anchor => 'e');
  23.     my $ent = $f->Entry(-width => 20);
  24.     my $but = $f->Button(-text => "Browse ...",
  25.                  -command => sub { fileDialog($TOP, $ent, $i)});
  26.     $lab->pack(-side => 'left');
  27.     $ent->pack(-side => 'left',-expand => 'yes', -fill => 'x');
  28.     $but->pack(-side => 'left');
  29.     $f->pack(-fill => 'x', -padx => '1c', -pady => 3);
  30.     }
  31.  
  32.     my $cbf = $TOP->Frame->pack(-fill => 'x', -padx => '1c', -pady => 3);
  33.     my $fd;
  34.     $cbf->Radiobutton
  35.       (-text => 'FileSelect',
  36.        -variable => \$fd,
  37.        -value => 'FileSelect',
  38.        -command => sub { local($^W) = 0;
  39.              require Tk::FileSelect;
  40.              Tk::FileSelect->import('as_default');
  41.              # XXX remove cached dialogs
  42.              my $mw = $TOP->MainWindow;
  43.              delete $mw->{'tk_getOpenFile'};
  44.              delete $mw->{'tk_getSaveFile'};
  45.              })->pack(-side => 'left');
  46.     my $fdb = $cbf->Radiobutton
  47.       (-text => 'FBox',
  48.        -variable => \$fd,
  49.        -value => 'FBox',
  50.        -command => sub { local($^W) = 0;
  51.              require Tk::FBox;
  52.              Tk::FBox->import('as_default');
  53.              # XXX remove cached dialogs
  54.              my $mw = $TOP->MainWindow;
  55.              delete $mw->{'tk_getOpenFile'};
  56.              delete $mw->{'tk_getSaveFile'};
  57.              })->pack(-side => 'left');
  58.     $fdb->invoke;
  59.  
  60. # XXX Motif style file box not implemented
  61. #     unless (compare($tcl_platform{'platform'},'unix'))
  62. #       {
  63. #       $w->{'.strict'} = $w->Checkbutton('Name','strict','-text',"Use Motif Style Dialog",'-variable','tk_strictMotif','-onvalue',1,'-offvalue',0);
  64. #       $w->{'.strict'}->pack('-anchor','c');
  65. #       }
  66. }
  67.  
  68. sub fileDialog {
  69.     my $w = shift;
  70.     my $ent = shift;
  71.     my $operation = shift;
  72.     my $types;
  73.     my $file;
  74.     #   Type names        Extension(s)    Mac File Type(s)
  75.     #
  76.     #---------------------------------------------------------
  77.     @types =
  78.       (["Text files",           [qw/.txt .doc/]],
  79.        ["Text files",           '',             'TEXT'],
  80.        ["Perl Scripts",         '.pl',        'TEXT'],
  81.        ["C Source Files",    ['.c', '.h']],
  82.        ["All Source Files",     [qw/.tcl .c .h/]],
  83.        ["Image Files",        '.gif'],
  84.        ["Image Files",        ['.jpeg', '.jpg']],
  85.        ["Image Files",       '',        [qw/GIFF JPEG/]],
  86.        ["All files",        '*']
  87.       );
  88.     if ($operation eq 'open') {
  89.     $file = $w->getOpenFile(-filetypes => \@types);
  90.     } else {
  91.     $file = $w->getSaveFile(-filetypes => \@types,
  92.                 -initialfile => 'Untitled',
  93.                 -defaultextension => '.txt');
  94.     }
  95.     if (defined $file and $file ne '') {
  96.     $ent->delete(0, 'end');
  97.     $ent->insert(0, $file);
  98.     $ent->xview('end');
  99.     }
  100. }
  101.